home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Libris Britannia 4
/
science library(b).zip
/
science library(b)
/
PROGRAMM
/
PASCAL
/
0189.ZIP
/
LOAN1.INC
< prev
next >
Wrap
Text File
|
1986-02-08
|
36KB
|
887 lines
const ZERO = 0; { Used to clarify code. }
FILL_CHAR = '_'; { Defines char. used to mark input fields. }
SPACE = ' '; { Represents the ASCII space character, #32 }
NULL = ''; { Represents a null string. }
{ Output Control Characters }
NUL = #0; { Null character. }
BELL = #7; { Causes a beep when output to a }
{ terminal that has sound. }
BS = #8; { Backspace. }
TAB = #9; { Tab character. }
LF = #10; { Line Feed. }
CR = #13; { Carriage Return. }
FF = #12; { Form Feed. }
ESC = #27; { Escape character. }
DEL = #127; { Del or Rubout character. }
{ Video Limits & Locations }
MAX_ROW = 24; { Maximum number of rows for video. }
MAX_COL = 80; { Maximum number of columns for video. }
MSG_LINE = 22; { Line to be used for user messages. }
PROMPT_LINE = 23; { Used for prompts, extended messages }
{ and commands. }
CMD_LINE = 24; { Primary command input line. }
{ Input Control Keys: Keyboard character code and video representation
of keys used in Loan_Amortization application.
Add others for general purpose use. The definitions
shown will work on any Turbo supported system. The
alternate definitions, which are commented out, will
allow the IBM-PC and compatibles to use function and
cursor control keys as indicated. }
BACKSP = BS; { Backspace or left arrow key. }
{ BS_KEY = #32#17#196#196#32; IBM-PC backspace key symbol. }
BS_KEY = ' <BkSpc> '; { Use text appropriate for keyboard. }
ENTER = CR; { Return or Enter key. }
{ ENTER_KEY = #32#17#196#217#32; IBM-PC enter key symbol. }
ENTER_KEY = ' <Enter> '; { Use text appropriate for keyboard. }
CLEAR = TAB; { Forward tab key or ^I. }
{ CLEAR_KEY = #32#196#196#16#221#32; IBM-PC tab key symbol. }
CLEAR_KEY = ' <Tab> '; { Use text appropriate for keyboard. }
QUIT = ESC; { Escape key. }
QUIT_KEY = ' <Esc> '; { Use text appropriate for keyboard. }
{ PREV = #72; IBM up arrow key scan code. }
{ PREV_KEY = #32#24#32; IBM-PC up arrow symbol. }
PREV = ^E; { Use code appropriate for key used. }
PREV_KEY = ' ^E '; { Use text appropriate for keyboard. }
{ HELP = #59; IBM-PC F1 key scan code. }
{ HELP_KEY = ' F1 '; IBM-PC }
HELP = ^A; { Use code appropriate for key used. }
HELP_KEY = ' ^A '; { Use text appropriate for keyboard. }
LEAD_IN = ESC; { Lead in char. for IBM function keys. }
{ Change as needed for other systems. }
{ String types: General purpose string types. }
type Str_5 = string[5];
Str_10 = string[10];
Str_15 = string[15];
Str_20 = string[20];
Str_30 = string[30];
Str_40 = string[40];
Str_60 = string[60];
Str_80 = string[80];
Str_255 = string[255];
File_ID = string[64];
Drive_ID = string[2];
{ Set types: }
Any_Char = set of Char; { Defined set of all characters. }
Printable_Char = set of ' '..'~'; { Set of printable characters. }
Special_Char = set of #128..#255; { Set of Non-standard characters. }
Control_Char = set of #0..#127; { Set of Control characters. This }
{ includes DEL and the IBM-PC }
{ function key scan codes. }
var default, { General purpose string buffer. }
inp_str : Str_255; { Keyboard input string buffer. }
i, j, k, { Misc. loop counter variables. }
io_status : Integer; { Global status variable. }
inctl, { Global control character. }
inchr : Char; { Global input character. }
output_id : File_ID; { Store ID of current output file/device.}
esc_flag, { Global logic control flags. }
err_flag,
help_flag,
quit_flag,
end_session : Boolean;
{ Additional global constants types and variables required for data
input and display routines. }
const MAX_FLD = 32; { Set maximum number of input fields permitted. }
{ Field input type codes. }
TEXT_FLD = 'T'; { Text field. Used for screen doc. only. }
UC_TEXT = 'U'; { Upper Case text field. }
NUMERIC = 'N'; { Numeric field. }
{ Field exit type codes. }
REQUIRED = 'R'; { Identifies field that requires an entry. }
PROTECTED = 'P'; { Identifies a field to be skipped during input. }
MANUAL = 'M'; { Manual exit field. User must press <CR>. }
AUTOMATIC = 'A'; { Automatic exit after last char. is entered. }
INCR = 1; { INCR & DECR are used to set the }
DECR = -1; { direction indicator variable. }
{ Define data structure to hold input field parameters. }
type Fld_Parms = record
xloc : Integer; { Video column. }
yloc : Integer; { Video row. }
fld_len : Integer; { Maximum field length. }
fld_type : Char; { See input constants above. }
exit_type : Char; { See exit constants above. }
fld_msg : Str_60; { User prompt message. }
end;
{ Define data structure to hold text for video screens. }
Scrn = array[1..MAX_ROW] of Str_80;
{ Define an array of field parameter records. }
Inp_Parms = array[1..MAX_FLD] of Fld_Parms; { Input field parameters. }
{ Define pointer and record for help screen text. }
Help_Pointer = ^Help_Text;
Help_Text = record
help_txt : Str_80;
next_line : Help_Pointer;
end;
{ Global variables used by standard input and display routines. }
var fld_cnt, { Holds number of fields on current screen. }
direction : Integer; { Increment/Decrement indicator. }
top_of_heap : ^Integer; { Dummy pointer for use by Mark & Release. }
first_help : Help_Pointer; { Pointer to first line of help text. }
{ Forward declaration of error handling routines which use some of the
routines in the STD-UTIL.INC file and are also used by some of these
routines. }
procedure Disp_IO_Error(device_name: File_ID); forward;
procedure Disp_Error_Msg(err_msg: Str_80); forward;
procedure Beep;
begin
Write(BELL); { Use this statement for non-IBM-PC systems. }
(* begin { This routine may be substituted on IBM-PC systems. }
Sound(440); Delay(250); NoSound;
end; *)
end; { Beep }
procedure Repeat_Char(character : Char; { Character to be output. }
count : Integer); { Number of times to output. }
var i : Integer;
begin
i := ZERO;
while (i < count) do
begin
Write(character);
i := Succ(i);
end;
end; { Repeat_Char }
procedure Strip_Trailing_Char(var inp_str : Str_255; { String to strip.}
len : Byte; { Maximum length. }
strip : Char); { Char. to strip. }
{ Scan inp_str from len downto 0 until a character <> strip is found.
Set the length of inp_str equal to the position of the character
found if any. Note that inp_str is set to null if it contains only
strip characters. }
begin
inp_str[0] := Chr(0); { Set inp_str length byte to ZERO. }
while (inp_str[len] = strip) and (len > ZERO) do
len := Pred(len);
inp_str[0] := Chr(len); { Set inp_str length to len. }
end; { Strip_Trailing_Char }
procedure Strip_Leading_Char(var inp_str : Str_255; { String to strip. }
len : Byte; { Maximum length. }
strip : Char); { Char. to strip. }
var i : Byte;
{ Find the first occurrence, if any, of a character not equal to strip.
Copy the remainder of inp_str into the new inp_str. Note inp_str is set
to null if it is null initially or it contains only strip characters. }
begin
i := 1;
While (inp_str[i] = strip) and (i <= len) do
i := Succ(i);
inp_str := Copy(inp_str,i,len);
end; { Strip_Leading_Char }
function Stripped(inp_str : Str_255; { String to strip. }
len : Byte; { Maximum length. }
strip : Char): Str_255; { Char. to strip. }
{ Uses procedures defined above to strip leading and trailing
occurances of the character strip from inp_str. }
begin
Strip_Trailing_Char(inp_str,len,strip);
Strip_Leading_Char(inp_str,len,strip);
Stripped := inp_str;
end; { Stripped }
function Exist(file_name: File_ID): Boolean;
var chk_file : File;
begin
Assign(chk_file,file_name);
{$I-} Reset(chk_file); {$I+}
Exist := (IOresult = ZERO);
{$I-} Close(chk_file); io_status := IOresult; {$I+}
end; { Exist }
procedure Read_Kbd(var inchr,inctl: Char);
{ Keyboard input routine that will allow users of systems with
`IBM-PC type' function keys to use those keys as control keys.
It will also work on systems using standard control keys producing
ASCII characters #1..#31 & #127. The variable parameters will
be set as follows depending on the key that is pressed.
inchr will contain the character value of the key pressed.
If a control/function key is pressed this will be the
`lead in' value for the key, if any. For example the
lead in character for function keys on many systems is the
escape character, ASCII #27.
inctl will contain NUL or a control/function key value which may be
used to determine whether a control/function key was pressed
and if so which key it was. }
begin
inctl := NUL; { Initialize to inctl to NUL. }
Read(Kbd,inchr); { Wait for a key to be pressed. }
if (KeyPressed and (inchr = LEAD_IN)) then
begin { Get function key scan code. }
Delay(0); { Increase Delay if needed. }
Read(Kbd,inctl); { Scan code goes in inctl. }
end
else
if (inchr in [#1..#31,DEL]) then
inctl := inchr; { Trap conventional control chrs.}
end; { Read_Kbd }
function Valid_Key(valid_keys: Any_Char): Char;
var inchr, inctl : Char;
{ Waits for a key to be pressed that is a member of the set valid_keys.
The ASCII value of the key is returned. Non-control keys are
displayed. A beep is sounded for invalid keys.
Note that alpha characters are forced to upper case. }
begin
repeat
Read_Kbd(inchr,inctl); { Wait for a key to be pressed. }
if (inctl = NUL) then
begin { If it is not a control key }
inchr := UpCase(inchr); { force it to upper case and }
Write(inchr,BS); { display it, restoring cursor. }
end
else { If it is a control key then }
inchr := inctl; { pass it through for testing. }
if (not (inchr in valid_keys)) then
Beep; { Beep if it's not valid. }
until (inchr in valid_keys);
Valid_Key := inchr; { Return the valid character. }
end; { Valid_Key }
procedure Init_Field (init_char : Char;
var parms : Fld_Parms);
var i : Byte;
{ Initialize field with init_char based on parms.
Parameters are:
init_char Fill character to be used for field initialization.
parms Input field parameters for the field to be initialized. }
begin
with parms do
begin
GoToXY(xloc,yloc); { Position cursor. }
Repeat_Char(init_char,fld_len); { Init field with init_char. }
GoToXY(xloc,yloc); { Restore cursor position. }
end;
end; { Init_Field }
procedure Get_Field_Input(var parms : Fld_Parms;
var chr_set : Printable_Char;
var ctrl_set : Control_Char);
var count : Integer; { Number of characters entered. }
exit : Boolean; { Local exit flag. }
{ General purpose keyboard input routine.
Parameters are:
parms Input field parameters for the field to be processed.
chr_set Set of characters acceptable for input. Beep for others.
ctrl_set Set of control/fuction characters acceptable for input. }
{ Global variables used:
esc_flag Boolean Global exit flag.
inp_str Str_255 Input buffer string. Note that
Length(inp_str) is set to count on exit.
direction Integer Increment/Decrement indicator. Switched to
DECR if valid control character is PREV.
inchr Char Used to store input character.
inctl Char Used to store input control/function code. }
procedure Process_Control_Character;
var i : Byte;
{ Select action based on control key pressed by user. }
{ Global variables used:
esc_flag : Boolean; Used to indicate that QUIT key pressed.
help_flag : Boolean; Used to indicate that HELP key pressed.
direction : Integer; Increment/Decrement indicator. }
procedure Backspace(fill: Char);
{ Perform destructive backspace on video and remove last character
from inp_str. The parameter is:
fill Character to be output in place of character deleted. }
begin
if (count > ZERO) then
begin
Write(BS,fill,BS); { Destructive backspace to video. }
count := Pred(count); { Decrement characters entered count. }
end
else
Beep; { Beep if count = ZERO initially. }
end; { Backspace }
procedure Clear_Field;
var i : Byte;
{ Initialize video field and clear input string. }
begin
Init_Field(FILL_CHAR,parms); { Clear video field. }
with parms do
FillChar(inp_str,fld_len + 1,ZERO); { Clear inp_str. }
count := ZERO; { Reset count to ZERO. }
end; { Clear_Field }
begin { Process_Control_Character }
case inctl of
BACKSP : Backspace(FILL_CHAR);
ENTER : exit := TRUE;
QUIT : begin
esc_flag := TRUE;
exit := TRUE;
end;
PREV : begin
Clear_Field;
direction := DECR;
exit := TRUE;
end;
CLEAR : begin
Clear_Field;
exit := TRUE;
end;
HELP : begin
help_flag := TRUE;
exit := TRUE;
end;
else Beep;
end; {case}
end; { Process_Control_Character }
procedure Accept_Valid_Character;
{ If inchr is a member of chr_set and that the field length has
not been exceeded, display inchr, increment count
and store the character in inp_str; otherwise Beep.
If the end of an AUTOMATIC exit field is reached set the exit
flag and indicate that a CR has been received by setting inctl to CR. }
begin
with parms do
begin
if (fld_type = UC_TEXT) then
inchr := UpCase(inchr);
if (inchr in chr_set) and (count < fld_len) then
begin
Write(inchr);
count := Succ(count);
inp_str[count] := inchr;
if (exit_type = AUTOMATIC) and (count = fld_len) then
begin
exit := TRUE; inctl := CR;
end;
end
else
Beep;
end;
end; { Accept_Valid_Character }
begin { Get_Field_Input }
count := ZERO;
esc_flag := FALSE; exit := FALSE;
direction := INCR;
repeat
Read_Kbd(inchr,inctl);
if (inctl in ctrl_set) then
Process_Control_Character
else
Accept_Valid_Character;
until exit;
inp_str[0] := Chr(count); { Set length of input string. }
Repeat_Char(SPACE,(parms.fld_len - count)); { Clear to end of field. }
end; { Get_Field_Input }
function Valid_Str(var parms: Fld_Parms): Str_80;
const chr_set : Printable_Char = [SPACE..'~'];
ctrl_set : Control_Char = [CR,BS,CLEAR,PREV,QUIT];
{ Accepts field input based on parms. If the user presses <CR> without
entering anything, the value of the global default string is returned.
Otherwise the characters entered, up to the maximum indicated by
parms.fld_len, are returned as a string. }
begin
Valid_Str := default; { Returns default if no value is entered. }
Get_Field_Input(parms,chr_set,ctrl_set);
if ((inctl = CR) and (Length(inp_str) > ZERO)) or
(inctl = CLEAR) then
Valid_Str := inp_str;
end; { Valid_Str }
function Valid_Real(var parms : Fld_Parms;
point : Byte;
min,max : Real): Real;
const chr_set : Printable_Char = ['0'..'9','-','.'];
ctrl_set : Control_Char = [CR,BS,CLEAR,PREV,QUIT];
var real_val : Real;
min_str,
max_str : Str_20;
err_msg : Str_80;
{ Accepts field input based on parms. If the user presses <CR> without
entering anything, the Real value of the global default string is returned.
Otherwise the string entered is converted to a Real value. If the value
is not in the range indicated by min and max or a there is an error in
the conversion, an error message is displayed. }
begin { Valid_Real }
Val(Stripped(default,Length(default),SPACE),real_val,io_status);
if io_status <> ZERO then { If default is a bad numeric value }
real_val := 0.0; { then return 0.0. }
Valid_Real := real_val; { Return default if no value is entered. }
Get_Field_Input(parms,chr_set,ctrl_set);
if ((inctl = CR) and (Length(inp_str) > ZERO)) or
(inctl = CLEAR) then
begin
if (inctl = CLEAR) then
inp_str := '0.00';
Val(inp_str,real_val,io_status);
if (io_status = ZERO) and
((real_val >= min) and (real_val <= max)) then
Valid_Real := real_val
else
begin
Str(min:parms.fld_len:point,min_str); { The point parameter }
Str(max:parms.fld_len:point,max_str); { indicates the position }
err_msg := 'Value must be from ' { of the decimal point. }
+ min_str + ' through ' + max_str;
Disp_Error_Msg(err_msg);
direction := ZERO; { Force re-entry of field. }
end;
end;
end; { Valid_Real}
function Valid_Int(var parms : Fld_Parms;
min,max : Integer): Integer;
const chr_set : Printable_Char = ['0'..'9','-'];
ctrl_set : Control_Char = [CR,BS,CLEAR,PREV,QUIT];
var int_val : Integer;
min_str,
max_str : Str_20;
err_msg : Str_80;
{ Accepts field input based on parms. If the user presses <CR> without
entering anything, the Integer value of the global default string is returned.
Otherwise the string entered is converted to an Integer value. If the value
is not in the range indicated by min and max or a there is an error in
the conversion, an error message is displayed. }
begin { Valid_Int }
Val(Stripped(default,Length(default),SPACE),int_val,io_status);
if io_status <> ZERO then { If default is a bad numeric value }
int_val := ZERO; { then return ZERO. }
Valid_Int := int_val; { Return default if no value is entered. }
Get_Field_Input(parms,chr_set,ctrl_set);
if ((inctl = CR) and (Length(inp_str) > ZERO)) or
(inctl = CLEAR) then
begin
if (inctl = CLEAR) then
inp_str := '0';
Val(inp_str,int_val,io_status);
if (io_status = ZERO) and
((int_val >= min) and (int_val <= max)) then
Valid_Int := int_val
else
begin
Str(min:parms.fld_len,min_str);
Str(max:parms.fld_len,max_str);
err_msg := 'Value must be from ' + min_str +
' through ' + max_str;
Disp_Error_Msg(err_msg);
direction := ZERO; { Forces re-entry of field. }
end;
end;
end; { Valid_Int }
function Valid_Chr(var parms : Fld_Parms;
valid_set : Printable_Char): Char;
const ctrl_set : Control_Char = [CR,BS,CLEAR,PREV,QUIT];
{ Accepts field input based on parms. If the user presses <CR> without
entering anything, the first character of the global default string is
returned. Otherwise the user must enter a character that is a member of
the valid_set parameter. }
begin { Valid_Chr }
Valid_Chr := default[1]; { Returns default if no value is entered. }
Get_Field_Input(parms,valid_set,ctrl_set);
if ((inctl = CR) and (Length(inp_str) > ZERO)) or
(inctl = CLEAR) then
Valid_Chr := inp_str[1]
end; { Valid_Chr }
procedure Clr_Eol(line: Byte);
var blank_line : Str_80;
{ Alternate clear to end of line routine for systems that scroll the
video screen when a Turbo ClrEol is executed on the 24th line.
}
begin
FillChar(blank_line,81,SPACE); blank_line[0] := Chr(79);
GoToXY(1,line); Write(blank_line);
GoToXY(1,line);
end; { Clr_Eol }
procedure Clear_Prompts;
{ Clears the prompt area as defined by the global constants used. }
begin
GoToXY(1,MSG_LINE); ClrEol;
GoToXY(1,PROMPT_LINE); ClrEol;
GoToXY(1,CMD_LINE); Clr_Eol(CMD_LINE); { Systems with 25 video lines }
end; { Clear_Prompts } { can use ClrEol. }
procedure Display_Prompt(line : Byte;
prompt : Str_10;
msg_str : Str_80);
{ Displays prompt & highlighted msg_str at line.
Parameters are:
line The video line on which the prompt and msg_str are displayed.
prompt A string that identifies the nature of the message.
msg_str The message to be displayed.
Note: The calling routine must preserve and restore the cursor position
and video intensity as needed.
Combined length of prompt & msg_str should be less than 76.
}
begin { Display_Prompt }
GoToXY(1,line); Clr_Eol(line); { Systems with 25 video lines }
LowVideo; { can use ClrEol. }
Write(Prompt,': '); NormVideo;
Write(msg_str);
end; { Display_Prompt }
procedure Disp_Error_Msg; { (err_msg: Str_80); }
var inchr : Char; { forward defined in STD-UTIL.PAS }
{ Displays err_msg at MSG_LINE and a `continue prompt' at PROMPT_LINE.
Clears both lines when user presses any key.
Note: The calling routine must preserve and restore cursor position and
video intensity as well as the contents of the MSG_LINE & PROMPT_LINE. }
begin
Display_Prompt(MSG_LINE,'ERR',err_msg); GoToXY(1,PROMPT_LINE);
Display_Prompt(PROMPT_LINE,
'MSG','Press ANY KEY to try again. ==> ');
Beep;
Read(Kbd,inchr); { Pause until key is pressed }
GoToXY(1,MSG_LINE); ClrEol; GoToXY(1,PROMPT_LINE); ClrEol;
end; { Disp_Error_Msg }
procedure Disp_IO_Error; { (device_name: File_ID); }
{ forward defined in STD-UTIL.PAS }
var IO_Msg : Str_80;
err_str : string[3];
valid_keys : Printable_Char;
{ Converts global io_status to a text error message combined with its
device_name parameter. Displays error message and sets global error_flag. }
begin
case io_status of
$01 : IO_Msg := 'not found';
$02 : IO_Msg := 'not open for input';
$03 : IO_Msg := 'not open for output';
$04 : IO_Msg := 'not open';
$05 : IO_Msg := 'not readable';
$06 : IO_Msg := 'not Assigned. Unable to Write';
$10 : IO_Msg := 'recieved bad numeric data';
$20 : IO_Msg := 'not able to perform operation requested';
$21 : IO_Msg := 'not available in Memory mode';
$22 : IO_Msg := 'not available for Assign statement';
$90 : IO_Msg := 'does not contain matching record type';
$91 : IO_Msg := 'does not contain record requested';
$99 : IO_Msg := 'end encountered unexpectedly';
$F0 : IO_Msg := 'cannot be written to';
$F1 : IO_Msg := 'cannot be written due to full Directory';
$F2 : IO_Msg := 'has exceeded the maximum file size';
$FF : IO_Msg := 'is no longer on the current disk';
else begin
Str(io_status:3,err_str);
IO_Msg := 'has experienced I/O error:' + err_str;
end;
end; {case}
Clear_Prompts;
IO_Msg := 'Device/File ' + device_name + ' ' + IO_Msg;
Display_Prompt(PROMPT_LINE,'MSG',IO_Msg);
Display_Prompt(CMD_LINE,'CMD','Ignore | Abort');
Display_Prompt(MSG_LINE,'INP',
'Press CMD: key to enter selection. (I/A) ==> ');
if (Valid_Key(['A','I']) = 'A') then
err_flag := TRUE
else
io_status := ZERO;
end; { Disp_IO_Error }
procedure Load_SCR_File(file_name : File_ID;
var text_buf : Scrn;
var text_file : Text);
var line_cnt : Byte;
{ Loads up to MAX_ROW lines of text from text_file into text_buf.
if text file contains more than MAX_ROW lines of text, io_status
is set to MAX_ROW + 1. Any other value of io_status greater than 0
should be treated as an I/O error. It is left to the calling routine
to handle such errors.
Text_file is left open so that the calling routine may Read additional
text if necessary. The caller is responsible for closing text_file. }
begin
Assign(text_file,file_name);
{$I-}
Reset(text_file); io_status := IOresult;
line_cnt := 1;
While (io_status = ZERO) and (not Eof(text_file)) do
if line_cnt > MAX_ROW then
io_status := line_cnt
else
begin
ReadLn(text_file,text_buf[line_cnt]);
io_status := IOresult;
if (io_status = ZERO) then
line_cnt := Succ(line_cnt)
else
Disp_IO_Error(file_name);
end;
{$I+}
end; { Load_SCR_File }
procedure Load_Input_Scrn(scrn_id : File_ID;
var scrn_text : Scrn;
var fld_dat : Inp_Parms);
type Txt_Num = string[2];
var scrn_file : Text;
txt_x, txt_y,
txt_cnt, txt_len : Txt_Num;
i : Byte;
dummy : Char;
{ Loads the screen text from file identified by scrn_id into the
screen buffer pointed to by scrn_text. The input field parameters
are then loaded into the fld_dat array. }
procedure Read_Field_Parameters;
var status : array[1..10] of Integer; { Used for error trapping. }
{ Reads parameters for fld_cnt fields into fld_dat parameter array.
The format of the parameter in scrn_file must be a follows:
n1,n2,n3,X,Y,Msg
n1 = 2 digit video screen row of input field.
n2 = 2 digit video screen col of input field.
n3 = 2 digit length in characters of input field.
X = 1 character field type as defined in global constants.
Y = 1 character field exit type as defined in global constants.
Msg = Up to 60 characters, followed by End Of Line. }
procedure Check_Status;
begin
i := 1; { Set up loop to check status }
while (i < 11) do
if (status[i] <> ZERO) then
begin { If error encountered, display }
io_status := status[i]; { error message and exit loop. }
Disp_IO_Error(scrn_id);
i := 11;
end
else
i := Succ(i);
end; { Check_Status }
begin { Read_Field_Parameters }
for i := 1 to fld_cnt do
With fld_dat[i] do
begin
{$I-}
Read(scrn_file,txt_y,dummy); status[1] := IOresult;
Read(scrn_file,txt_x,dummy); status[2] := IOresult;
Read(scrn_file,txt_len,dummy); status[3] := IOresult;
Read(scrn_file,fld_type,dummy); status[4] := IOresult;
Read(scrn_file,exit_type,dummy); status[5] := IOresult;
ReadLn(scrn_file,fld_msg); status[6] := IOresult;
Val(txt_x,xloc,io_status); status[7] := io_status;
Val(txt_y,yloc,io_status); status[8] := io_status;
Val(txt_len,fld_len,io_status); status[9] := io_status;
end;
Close(scrn_file); status[10] := IOresult;
{$I+}
Check_Status; { Display first error encountered & set error_flag. }
end; { Read_Field_Parameters }
begin { Load_Input_Scrn }
Load_SCR_File(scrn_id,scrn_text,scrn_file); { Load screen text. }
if (io_status = (MAX_ROW + 1)) then
begin
{$I+}
ReadLn(scrn_file,txt_cnt); { Read number of fields. }
io_status := IOresult;
{$I-}
if (io_status = ZERO) then
Val(txt_cnt,fld_cnt,io_status); { Convert fld_cnt to number.}
if (io_status = ZERO) then
Read_Field_Parameters
else
begin
Disp_Error_Msg('Conversion error in screen file.');
err_flag := TRUE;
end;
end
else
begin
Disp_Error_Msg('Invalid input screen file.');
err_flag := TRUE;
end;
end { Load_Input_Scrn };
procedure Disp_Input_Scrn(inp_scrn: Scrn);
var i : Byte;
{ Writes text from inp_scrn screen text buffer to video. }
begin
NormVideo;
for i := 1 to 4 do WriteLn(inp_scrn[i]);
LowVideo;
for i := 5 to (MAX_ROW -1) do
WriteLn(inp_scrn[i]);
Write(inp_scrn[MAX_ROW]); { Required to prevent scrolling on systems }
NormVideo; { with MAX_ROW video lines. }
end { Disp_Input_Scrn };
procedure Load_Help_Text(file_name: File_ID);
const MIN_HEAP = $800; { Leave at least 2K free on the heap. }
var help_file : Text;
new_line,
last_line : Help_Pointer;
begin
Mark(top_of_heap);
first_help := nil;
Assign(help_file,file_name);
{$I-}
Reset(help_file); io_status := IOresult;
while ((not Eof(help_file)) and (MemAvail > MIN_HEAP)) and
(io_status = ZERO) do
begin
New(new_line);
ReadLn(help_file,new_line^.help_txt);
io_status := IOresult;
if (first_help = nil) then
first_help := new_line
else
last_line^.next_line := new_line;
last_line := new_line;
last_line^.next_line := nil;
end;
{$I+}
if (io_status <> ZERO) then
Disp_IO_Error(file_name);
if (MemAvail <= MIN_HEAP) then
Disp_Error_Msg('Insufficient memory for complete help file');
end; { Load_Help_Text }
procedure Disp_Help(first, last: Integer);
var line_ptr : Help_Pointer;
line_cnt : Integer;
{ Displays `help screen' information from dynamic memory. The information
displayed is determined by first and last, which refer to line numbers
in help_file. Information is displayed starting at row 1 with a dashed
line followed by (last - first + 1) lines of help text and ends on row
(last - first + 3) which is another dashed line.
Note: The calling routine must preserve and restore screen contents.
Last - first should be less than 20. }
begin
GoToXY(1,1); Repeat_Char('-',(MAX_COL - 1)); WriteLn;
line_ptr := first_help;
line_cnt := 1;
while (line_cnt < first) and (line_ptr <> nil) do
begin
line_ptr := line_ptr^.next_line;
line_cnt := Succ(line_cnt);
end;
while (line_cnt <= last) and (line_ptr <> nil) do
begin
ClrEol;
WriteLn(line_ptr^.help_txt);
line_ptr := line_ptr^.next_line;
line_cnt := Succ(line_cnt);
end;
Repeat_Char('-',(MAX_COL - 1));
Clear_Prompts;
Display_Prompt(MSG_LINE,'MSG','Press ANY KEY to continue... ');
Read(Kbd,inchr);
end; { Disp_Help }
procedure Verify_Exit;
begin
Display_Prompt(MSG_LINE,'INP','Do you want to END this session? (Y/N) ==> ');
if (Valid_Key(['Y','N']) = 'Y') then
end_session := TRUE;
end; { Verify_Exit }